perm filename HAIRY.SAI[PNT,HE] blob
sn#225371 filedate 1976-10-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00016 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
C00004 00003 ! additional node types, globals
C00006 00004 ! new_motion_info, new_place_info
C00009 00005 ! rot_is_nil, transl_is_nil, xf_is_nil, find_place_vbl
C00011 00006 ! place_al, ms_al, place_string,motion_string
C00017 00007 ! tree_string
C00019 00008 ! update
C00021 00009 ! λλ
C00023 00010 ! distance thresholds, nil_enough, close_enough
C00026 00011 ! startspot, reasonable_base
C00028 00012 ! there
C00029 00013 ! ms_start, ms_place, replace_ms_place
C00034 00014 ! setb
C00037 00015 ! toplevel
C00040 00016 ! main program
C00041 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
BEGIN "HAIRY"
DEFINE HAIRY_VERSION="TRUE";
REQUIRE "NODES.SAI[PNT,PJ]" SOURCE_FILE;
REQUIRE "SYS:PROCES.DEF" SOURCE_FILE;
ENDC
! additional node types, globals;
RCLASS NODE_INFO(INTEGER HOWMADE;
RPTR(NODE) LAST_BASE; ! last node used as a BASE when
this node used as a place vbl;
RPTR(NODE) LAST_DEST; ! last place this guy was moved to;
STRING COMMENTARY);
DEFINE USER_CREATED = 0;
DEFINE INVENTED_NODE=1;
RCLASS MOTION_INFO(STRING QUALIFIERS;RPTR(NODE) MF,M0V;INTEGER PLACECOUNT);
RCLASS PLACE_INFO(STRING QUALIFIERS;RPTR(NODE) VBL,BASE);
RCLASS BLOCK_INFO(STRING QUALIFIERS);
DEFINE NODE_KIND = 0; ! default node is just a node;
DEFINE MOTION_KIND = 1;
DEFINE PLACE_KIND = 2;
DEFINE BLOCK_KIND = 3;
RPTR(NODE) PROGRAM; ! top of the "program" tree;
RPTR(NODE) M0; ! M0 is used to hold initial value of motion frame;
! new_motion_info, new_place_info;
RPTR(BLOCK_INFO) PROCEDURE NEW_BLOCK_INFO(STRING QUALS(NULL));
BEGIN
RPTR(BLOCK_INFO) BI;
BI←NEW_RECORD(BLOCK_INFO);
BLOCK_INFO:QUALIFIERS[BI]←QUALS;
RETURN(BI);
END;
RPTR(MOTION_INFO) PROCEDURE NEW_MOTION_INFO(RPTR(NODE) MF(NULL_RECORD),
M0V(NULL_RECORD);
STRING QUALS(NULL));
BEGIN
RPTR(MOTION_INFO) MI;
MI←NEW_RECORD(MOTION_INFO);
MOTION_INFO:QUALIFIERS[MI]←QUALS;
MOTION_INFO:MF[MI]←MF;
MOTION_INFO:M0V[MI]←M0V;
RETURN(MI);
END;
RPTR(PLACE_INFO) PROCEDURE NEW_PLACE_INFO(RPTR(NODE) VBL(NULL_RECORD),
BASE(NULL_RECORD);
STRING QUALS(NULL));
BEGIN
RPTR(PLACE_INFO) PI;
PI←NEW_RECORD(PLACE_INFO);
PLACE_INFO:QUALIFIERS[PI]←QUALS;
PLACE_INFO:VBL[PI]←VBL;
PLACE_INFO:BASE[PI]←BASE;
RETURN(PI);
END;
RPTR(NODE_INFO) PROCEDURE NEW_NODE_INFO(INTEGER HOWMADE(USER_CREATED);
RPTR(NODE) LAST_BASE(NULL_RECORD),
LAST_DEST(NULL_RECORD);
STRING COMMENTARY(NULL));
BEGIN
RPTR(NODE_INFO) NI;
NI←NEW_RECORD(NODE_INFO);
NODE_INFO:HOWMADE[NI]←HOWMADE;
NODE_INFO:LAST_BASE[NI]←LAST_BASE;
NODE_INFO:LAST_DEST[NI]←LAST_DEST;
NODE_INFO:COMMENTARY[NI]←COMMENTARY;
RETURN(NI);
END;
RPTR(NODE) PROCEDURE NEW_NODE(STRING PN;
INTEGER KIND(NODE_KIND);
RPTR(ANY_CLASS) INFO(NULL_RECORD));
BEGIN
REAL ARRAY A[1:5,1:4];
RPTR(NODE) ND;
ND←NEW_RECORD(NODE);
IF INFO=NULL_RECORD THEN
CASE KIND OF
BEGIN
[NODE_KIND] INFO←NEW_NODE_INFO;
[MOTION_KIND] INFO←NEW_MOTION_INFO;
[PLACE_KIND] INFO←NEW_PLACE_INFO;
[BLOCK_KIND] INFO←NEW_BLOCK_INFO
END;
NODE:PNAME[ND]←PN;
NODE:KIND[ND]←KIND;
NODE:INFO[ND]←INFO;
A[1,1]←A[2,2]←A[3,3]←A[4,4]←1.0;
MEMORY[LOCATION(A)]↔MEMORY[LOCATION(NODE:XF[ND])];
IF LENGTH(PN)>0 THEN
ENSYM(PN,ND);
RETURN(ND);
END;
! rot_is_nil, transl_is_nil, xf_is_nil, find_place_vbl;
BOOLEAN SIMPLE PROCEDURE ROT_IS_NIL(REAL ARRAY XF);
BEGIN
REAL W,PH,TH;
DECODE_ROTATION(XF,W,PH,TH);
RETURN(ABS(W)+ABS(TH)+ABS(PH)<TINY);
END;
BOOLEAN SIMPLE PROCEDURE TRANSL_IS_NIL(REAL ARRAY XF);
RETURN(ABS(XF[1,4])+ABS(XF[2,4])+ABS(XF[3,4])<TINY);
BOOLEAN SIMPLE PROCEDURE XF_IS_NIL(REAL ARRAY XF);
RETURN(TRANSL_IS_NIL(XF) ∧ ROT_IS_NIL(XF));
MATCHING RECPROC FIND_PLACE_VBL(RPTR(NODE) VB,PL0;
REFERENCE RPTR(NODE) PLK;
REFERENCE INTEGER DIST;
INTEGER DIR(1));
BEGIN
SPROUT_DEFAULTS PSTACK(4);
IF DIR=0 THEN
BEGIN
∀ | FIND_PLACE_VBL(VB,PL0,PLK,DIST,1) DO
SUCCEED;
∀ | FIND_PLACE_VBL(VB,PL0,PLK,DIST,-1) DO
IF ABS(DIST)>0 THEN SUCCEED;
END
ELSE
BEGIN
DIST←0;
PLK←PL0;
WHILE PLK≠NULL_RECORD DO
BEGIN
IF PLACE_INFO:VBL[NODE:INFO[PLK]]=VB THEN
SUCCEED;
DIST←DIST+DIR;
IF DIR>0 THEN
PLK←NODE:YBRO[PLK]
ELSE
PLK←NODE:EBRO[PLK];
END;
END;
FAIL;
END;
! place_al, ms_al, place_string,motion_string;
BOOLEAN SHOW_AL;INITIALIZE(SHOW_AL←FALSE);
BOOLEAN MUST_BE_ATOMIC;INITIALIZE(MUST_BE_ATOMIC←FALSE);
SIMPLE STRING PROCEDURE STMSEP;
RETURN(IF MUST_BE_ATOMIC THEN " " ELSE ";");
STRING PROCEDURE VBL_STRING(RPTR(NODE) V);
RETURN(NODE:PNAME[V]);
STRING PROCEDURE PLACE_AL(RPTR(NODE) PL);
BEGIN
RPTR(PLACE_INFO) PI;
RPTR(NODE) PV;
PI←NODE:INFO[PL];
PV←PLACE_INFO:VBL[PI];
RETURN(VBL_STRING(PV)&" "&PLACE_INFO:QUALIFIERS[PI]);
END;
STRING PROCEDURE MS_AL(RPTR(NODE) M;INTEGER TABIN(0));
BEGIN
RPTR(MOTION_INFO) MI;
STRING MS;
RPTR(NODE) PL;
RPTR(PLACE_INFO) PI;
MI←NODE:INFO[M];
IF MUST_BE_ATOMIC THEN
MS←BLANKS[1 FOR TABIN]&"BEGIN "&CRLF;
MS←MS&BLANKS[1 FOR TABIN]&"M0←"&NODE:PNAME[MOTION_INFO:MF[MI]]&";"&CRLF;
MS←MS&BLANKS[1 FOR TABIN]&"MOVE "&NODE:PNAME[MOTION_INFO:MF[MI]]&" TO "&
VBL_STRING(NODE:SON[M])&CRLF;
IF LENGTH(MOTION_INFO:QUALIFIERS[MI])>0 THEN
MS←MS&BLANKS[1 FOR TABIN]&MOTION_INFO:QUALIFIERS[MI]&CRLF;
PL←ELDEST_SON(M);
WHILE PL≠NULL_RECORD DO
BEGIN
PI←NODE:INFO[PL];
IF LENGTH(PLACE_INFO:QUALIFIERS[PI])>0 OR
(NODE:YBRO[PL]≠NULL_RECORD AND NODE:EBRO[PL]≠NULL_RECORD) THEN
BEGIN
MS←MS&BLANKS[1 FOR TABIN]&
" VIA "&PLACE_AL(PL)&CRLF;
END;
PL←NODE:YBRO[PL];
END;
IF MUST_BE_ATOMIC THEN
MS←MS&BLANKS[1 FOR TABIN]&"END"&CRLF;
RETURN(MS&STMSEP);
END;
STRING PROCEDURE PLACE_STRING(RPTR(NODE) PL);
BEGIN
RPTR(PLACE_INFO) PI;
RPTR(NODE) PV;
STRING PS;
PI←NODE:INFO[PL];
PV←PLACE_INFO:VBL[PI];
IF PL=CURPLACE THEN PS←STACK:ID[$CURPLACE] ELSE PS←" ";
PS←PS&"["&NODE:PNAME[PL]&"] "&NODE:PNAME[PV]&
" ( BASE = "&NODE:PNAME[PLACE_INFO:BASE[PI]]&
") "&PLACE_INFO:QUALIFIERS[PI];
RETURN(PS);
END;
STRING PROCEDURE MOTION_STRING(RPTR(NODE) M;INTEGER TABIN(0));
BEGIN
RPTR(NODE) PL;
RPTR(MOTION_INFO) MI;
STRING MS;
IF M=NULL_RECORD THEN RETURN("COMMENT <NULL MOTION>;"&CRLF);
IF SHOW_AL THEN RETURN(MS_AL(M,TABIN));
MI←NODE:INFO[M];
MS←"["&NODE:PNAME[M]&"] MOVE "&NODE:PNAME[MOTION_INFO:MF[MI]]&
" THRU POINTS:"&CRLF;
PL←ELDEST_SON(M);
WHILE PL≠NULL_RECORD DO
BEGIN
MS←MS&PLACE_STRING(PL)&CRLF;
PL←NODE:YBRO[PL];
END;
IF LENGTH(MOTION_INFO:QUALIFIERS[MI])>0 THEN
MS←MS&MOTION_INFO:QUALIFIERS[MI]&CRLF;
RETURN(MS);
END;
FORWARD STRING RECURSIVE PROCEDURE STMNT_STRING(RPTR(NODE) S;
INTEGER DEPTH(0),MAXDEPTH(999));
STRING RECURSIVE PROCEDURE BLOCK_STRING(RPTR(NODE) B;INTEGER DEPTH(0),MAXDEPTH(999));
BEGIN
RPTR(NODE) S;
STRING BS;
BS←"BEGIN """&NODE:PNAME[B]&""" "&BLOCK_INFO:QUALIFIERS[NODE:INFO[B]];
S←ELDEST_SON(B);
IF DEPTH≥MAXDEPTH THEN
BS←BS&" ... "
ELSE IF S≠NULL_RECORD THEN
BEGIN
BS←BS&CRLF;
DO BEGIN
BS←BS&STMNT_STRING(S,DEPTH+1,MAXDEPTH);
S←NODE:YBRO[S];
END UNTIL S=NULL_RECORD;
END;
RETURN(BS&"END"&STMSEP&CRLF);
END;
STRING RECURSIVE PROCEDURE STMNT_STRING(RPTR(NODE) S;
INTEGER DEPTH(0),MAXDEPTH(999));
BEGIN
STRING BS;
IF S=CURPROG THEN BS←STACK:ID[$CURPROG] ELSE BS←NULL;
IF S=CURSTMNT THEN BS←BS&STACK:ID[$CURSTMNT];
IF LENGTH(BS)<3*DEPTH THEN
BS←BS&BLANKS[1 FOR 3*DEPTH-LENGTH(BS)];
CASE NODE:KIND[S] OF
BEGIN
[MOTION_KIND] BS←BS&MOTION_STRING(S,3*DEPTH);
[BLOCK_KIND] BS←BS&BLOCK_STRING(S,DEPTH,MAXDEPTH)
END;
RETURN(BS);
END;
! tree_string;
BOOLEAN SHOWINVENTED;INITIALIZE(SHOWINVENTED←FALSE);
RECURSIVE STRING PROCEDURE TREE_STRING(RPTR(NODE) ND;
INTEGER DEPTH(0),MAXDEPTH(999));
BEGIN
RPTR(STACK) CSR;
STRING TS;
INTEGER L;
DEPTH←DEPTH+1;
IF DEPTH>MAXDEPTH THEN RETURN(NULL);
IF ¬SHOWINVENTED THEN
IF NODE_INFO:HOWMADE[NODE:INFO[ND]]=INVENTED_NODE THEN
RETURN(NULL);
TS←NULL;
FOR CSR← CURSORS DO
BEGIN
INTEGER PDP;
PDP←STACK:PDP[CSR];
IF PDP≥0 ∧ STACK:A[CSR][PDP]=ND THEN
TS←TS&STACK:ID[CSR];
END;
L←DEPTH*4-LENGTH(TS);
IF L<0 THEN
TS←TS&CRLF&BLANKS[1 FOR DEPTH*4]
ELSE
TS←TS&BLANKS[1 FOR L];
TS←TS&"-+*"[1+NODE:HOWLINKED[ND] FOR 1]&NODE:PNAME[ND];
IF SHOWXFS THEN
TS←TS&" at "&TSTR(NODE:XF[ND]);
IF SHOWLINKS THEN
BEGIN
TS←TS&"[↑"&NDNAME(NODE:DAD[ND])&",↓"&NDNAME(NODE:SON[ND])
&",←"&NDNAME(NODE:EBRO[ND])&",→"&NDNAME(NODE:YBRO[ND])&"]";
END;
TS←TS&CRLF;
ND←ELDEST_SON(ND);
WHILE ND≠NULL_RECORD DO
BEGIN
TS←TS&TREE_STRING(ND,DEPTH,MAXDEPTH);
ND←NODE:YBRO[ND];
END;
RETURN(TS);
END;
! update;
INTEGER SHOW_STMNT,SHOW_TREE;
INITIALIZE(BEGIN SHOW_STMNT←0;SHOW_TREE←1;END);
PROCEDURE UPDATE;
BEGIN
STRING AREA1STR;
IF UPDSUPPRESS>0 THEN RETURN;
DPYSET(DBUF);
DPYBIG(DPYCSIZE);
TYPLOC(PPTMAR-CHRSIZE,DBMAR);
DRAWBOX(DLMAR,DTMAR,DRMAR,PPTMAR);
DRAWLINE(CLMAR,DTMAR,CLMAR,ATMAR);
DRAWLINE(DLMAR,ATMAR,DRMAR,ATMAR);
DRAWLINE(DLMAR,BTMAR,DRMAR,BTMAR);
IF SHOW_TREE THEN
AREA1STR←TREE_STRING(CURTREE,0,MAXDEPTH)
ELSE
AREA1STR←NULL;
IF SHOW_STMNT THEN
AREA1STR←AREA1STR&CRLF&" "&CRLF&STMNT_STRING(CURSTMNT);
TXTBLK(AREA1STR,
DLMAR+5,DTMAR-CHRSIZE-5,
CLMAR-DLMAR-10,AFXLINES);
TXTBLK(ASTK_STRING($ASTACK),
DLMAR+5,ATMAR-CHRSIZE-5,
DRMAR-DLMAR-10,ARITHLINES);
TXTBLK(ASTK_STRING($BSTACK),
DLMAR+5,BTMAR-CHRSIZE-5,
DRMAR-DLMAR-10,ARITHLINES);
TXTBLK( OPENFIDS,
DLMAR+5,PPTMAR+10+CHRSIZE,
DRMAR-DLMAR-10,1);
IF LASTCURSOR≠NULL_RECORD THEN
TXTBLK(CSR_STRING(LASTCURSOR),
CLMAR+5,DTMAR-CHRSIZE-5,
DRMAR-CLMAR-10,AFXLINES-2);
TXTBLK("LAST λ:"&CRLF&" "&LASTλ&CRLF,
CLMAR+5,ATMAR+10+2*CHRSIZE,DRMAR-CLMAR-10,2);
DPYOUT(1);
END;
! λλ;
IFCR FALSE THENC
RPTR(NODE) PROCEDURE λλ(STRING ID(NULL),DADID(NULL));
BEGIN
STRING IDD,HID;
RPTR(NODE) ND,DD;
BOOLEAN BIGNS;
SIMPLE PROCEDURE BIGNRST;
BAD_ID_GIVES_NULL←BIGNS;
CLEANUP BIGNRST;
IF λλDAD=NULL_RECORD THEN
λλDAD←WORLD;
BIGNS←BAD_ID_GIVES_NULL;
BAD_ID_GIVES_NULL←TRUE;
ND←λ(ID);
IF ND=NULL_RECORD THEN
BEGIN
BIGNRST;
IDD←ID&".";
HID←SCAN(IDD,DOTBRK);
IF LENGTH(IDD)=0 THEN
HID↔IDD
ELSE
IDD←IDD[1 TO ∞-1]; ! flush the dot again;
IF LENGTH(HID)>0 THEN
DD←λ(HID)
ELSE IF LENGTH(DADID)>0 THEN
DD←λ(DADID)
ELSE
DD←WORLD;
ND←NEW_NODE(IDD);
LNK_NODE(ND,DD);
END;
RETURN(ND);
END;
ENDC
! distance thresholds, nil_enough, close_enough;
REAL BASE_PROXIMITY_THRESHOLD;
REAL SIMPLE PROCEDURE BPTSET(REAL R(-1));
BEGIN
RETURN(BASE_PROXIMITY_THRESHOLD←
IF R≥0 THEN R ELSE BASE_PROXIMITY_THRESHOLD);
END;
INITIALIZE(BPTSET(1*INCHES));
REAL PROCEDURE XFDISTANCE(REAL ARRAY XF1,XF2);
BEGIN
OWN REAL ARRAY XF3[1:5,1:4];
INVXFXF(XF1,XF2,XF3);
RETURN(SQRT(XF3[1,4]↑2+XF3[2,4]↑2+XF3[3,4]↑2));
END;
REAL PROCEDURE NNDISTANCE(RPTR(NODE) N1,N2);
BEGIN
OWN REAL ARRAY XF1,XF2[1:5,1:4];
ABSXF(N1,XF1);
ABSXF(N2,XF2);
RETURN(XFDISTANCE(XF1,XF2));
END;
REAL DXTHRESH,DYTHRESH,DZTHRESH,DROFXTHRESH,DROFZTHRESH;
PROCEDURE THRESHSET(REAL DPOS(0.5),DROT(10));
BEGIN
DXTHRESH←DYTHRESH←DZTHRESH←DPOS*INCHES;
DROFXTHRESH←DROFZTHRESH←DROT*DEG;
END;
INITIALIZE(THRESHSET);
BOOLEAN PROCEDURE NIL_ENOUGH(REAL ARRAY XF;
REAL DROFX(-1),DROFZ(-1),
DX(-1),DY(-1),DZ(-1));
BEGIN
REAL RX,RY,RZ;
SIMPLE BOOLEAN PROCEDURE VALCHK(REAL A,DA,DFDA);
IF DA<0 THEN RETURN(ABS(A)≤DFDA) ELSE RETURN(ABS(A)≤DA);
IF VALCHK(XF[1,4],DX,DXTHRESH)
∧ VALCHK(XF[2,4],DY,DYTHRESH)
∧ VALCHK(XF[3,4],DZ,DZTHRESH) THEN
BEGIN
IF VALCHK(ANGLETURNS(XF,UXVECT),DROFX,DROFXTHRESH)
∧VALCHK(ANGLETURNS(XF,UZVECT),DROFZ,DROFZTHRESH) THEN
RETURN(TRUE);
END;
RETURN(FALSE);
END;
BOOLEAN PROCEDURE CLOSE_ENOUGH(REAL ARRAY XF1,XF2;
REAL DROFX(-1),DROFZ(-1),
DX(-1),DY(-1),DZ(-1));
BEGIN
OWN REAL ARRAY XF3[1:5,1:4];
INVXFXF(XF1,XF2,XF3);
RETURN(NIL_ENOUGH(XF3,DROFX,DROFZ,DX,DY,DZ));
END;
! startspot, reasonable_base;
RPTR(NODE) PROCEDURE STARTSPOT(RPTR(NODE) ND);
BEGIN
ABSXF(ND,NODE:XF[M0]);
RETURN(M0);
END;
BOOLEAN PROCEDURE REASONABLE_BASE(RPTR(NODE) B,V);
BEGIN
! returns TRUE is B is a "reasonable" base for V;
REAL ARRAY VXF,BXF[1:5,1:4];
RPTR(NODE) F;
REAL BVDIST,BFDIST;
IF B=WORLD THEN RETURN(TRUE);
ABSXF(B,BXF);
ABSXF(V,VXF);
BVDIST←XFDISTANCE(BXF,VXF);
IF BVDIST≤BASE_PROXIMITY_THRESHOLD THEN
RETURN(TRUE);
F←NODE:SON[B];
WHILE F≠NULL_RECORD DO
BEGIN
ABSXF(F,VXF);
BFDIST←XFDISTANCE(BXF,VXF);
IF BVDIST≤(BFDIST+BASE_PROXIMITY_THRESHOLD) THEN
RETURN(TRUE);
F←NODE:EBRO[F];
END;
RETURN(FALSE);
END;
! there;
RPTR(NODE) PROCEDURE THERE(STRING ID;RPTR(NODE) DEFINER(NULL_RECORD));
BEGIN
RPTR(NODE) ND;
IF DEFINER=NULL_RECORD THEN
DEFINER←CURMOVE;
IF DEFINER=NULL_RECORD THEN
ABORT("WHAT IS ""THERE""?");
READARM;
MK_NODE(ID);
ABSXF(DEFINER,NODE:XF[CURNODE]);
UPDATE;
RETURN(CURNODE);
END;
! ms_start, ms_place, replace_ms_place;
PROCEDURE MS_START(STRING MSID;RPTR(NODE) P0V(NULL_RECORD));
BEGIN
RPTR(NODE) P0B;
READARM;
IF P0V=NULL_RECORD THEN
BEGIN
P0V←STARTSPOT(CURMOVE);
END;
PUSHSTK($CURSTMNT,NEW_NODE(MSID,
MOTION_KIND,
NEW_MOTION_INFO(CURMOVE,P0V)));
LNK_NODE(CURSTMNT,CURPROG);
P0B←P0V;
PUSHSTK($CURPLACE,NEW_NODE(MSID&"?0",
PLACE_KIND,
NEW_PLACE_INFO(P0V,P0B)));
ABSXF(CURMOVE,NODE:XF[CURPLACE]);
LNK_NODE(CURPLACE,CURSTMNT);
UPDATE;
END;
PROCEDURE MS_PLACE(RPTR(NODE) PIV(NULL_RECORD);BOOLEAN READMF(TRUE));
BEGIN
RPTR(NODE) PREVPL,PL;
RPTR(PLACE_INFO) PI;
RPTR(NODE) PIB;
RPTR(NODE) MS;
RPTR(MOTION_INFO) MI;
INTEGER PLACENO;
REAL DIST;
REAL ARRAY VXF,NPXF[1:5,1:4];
READARM;
PREVPL←CURPLACE;
MS←NODE:DAD[PREVPL];
MI←NODE:INFO[MS];
IF NODE:KIND[MS]≠MOTION_KIND ∨ MS≠CURSTMNT THEN
ABORT("MOTION STATEMENT CONTEXT CONFUSED");
PLACENO←MOTION_INFO:PLACECOUNT[MI]←MOTION_INFO:PLACECOUNT[MI]+1;
PIB←PLACE_INFO:BASE[NODE:INFO[PREVPL]];
IF READMF THEN
ABSXF(CURMOVE,NPXF)
ELSE IF PIV≠NULL_RECORD THEN
ABSXF(PIV,NPXF)
ELSE
ABORT("You must either supply place or read curmove!");
IF PIV=NULL_RECORD THEN
BEGIN
PIV←NEW_NODE(NODE:PNAME[MS]&"?"&CVS(PLACENO)&"V",
NODE_KIND,
NEW_NODE_INFO(INVENTED_NODE));
ARRTRAN(NODE:XF[PIV],NPXF);
! We've just invented a new variable node.
Now, see if this base is reasonable. If not,
run back up tree from it until get one that is.
;
WHILE ¬REASONABLE_BASE(PIB,PIV) DO
PIB←NODE:DAD[PIB];
AFX_NODE(PIV,PIB,NRGLNK);
END
ELSE
BEGIN
! User has suggested a variable.
First, check to see if this spot is reasonable
approximation to the place meant. Then, decide
what motion base to use from here on out.
;
ABSXF(PIV,VXF);
IF NOT CLOSE_ENOUGH(VXF,NPXF) THEN
BEGIN
! just doesn't make sense;
ABORT(" POINT NOT CLOSE ENOUGH TO PREVIOUS DEF ");
END;
IF ¬REASONABLE_BASE(PIB,PIV) THEN
PIB←PIV;
END;
PI←NEW_PLACE_INFO(PIV,PIB);
SETTOP($CURPLACE,NEW_NODE(NODE:PNAME[MS]&"?"&CVS(PLACENO),
PLACE_KIND,
PI));
ABSXF(CURMOVE,NODE:XF[CURPLACE]);
LNK_AFTER(PREVPL,CURPLACE);
IF NODE:YBRO[CURPLACE]=NULL_RECORD THEN
BEGIN
NODE_INFO:LAST_DEST[NODE:INFO[CURMOVE]]←PIV;
END;
UPDATE;
END;
PROCEDURE REPLACE_MS_PLACE(RPTR(NODE) VBL(NULL_RECORD);BOOLEAN READMF(TRUE));
BEGIN
RPTR(NODE) PL;
PL←NODE:EBRO[CURPLACE];
IF PL=NULL_RECORD THEN
ABORT("Sorry, cannot replace first place");
UNLNK_NODE(CURPLACE);
SETTOP($CURPLACE,PL);
MS_PLACE(VBL,READMF);
END;
! setb;
PROCEDURE SETB(RPTR(NODE) PL,B);
BEGIN
! sets the base of place PL to B.
propogates nothing.
;
RPTR(PLACE_INFO) PI;
IF NODE:KIND[PL]≠PLACE_KIND THEN
ABORT("SETB OF NON-PLACE");
PI←NODE:INFO[PL];
IF NOT IS_ANCESTOR(PLACE_INFO:VBL[PI],B) THEN
AFX_NODE(PLACE_INFO:VBL[PI],B,NRGLNK);
PLACE_INFO:BASE[PI]←B;
UPDATE;
END;
PROCEDURE SETBP(RPTR(NODE) PL,B);
BEGIN
! does setb(pl,b) & considers propogating result;
RPTR(PLACE_INFO) PI;
RPTR(NODE) OB,PK;
IF NODE:KIND[PL]≠PLACE_KIND THEN
ABORT("SETBP OF NON-PLACE");
PI←NODE:INFO[PL];
OB←PLACE_INFO:BASE[PI];
SETB(PL,B);
PK←NODE:EBRO[PL]; ! propogate backwards;
WHILE PK≠NULL_RECORD DO
BEGIN
! only ask guy if it seems reasonable to do so.
;
IF NODE:KIND[PK]≠PLACE_KIND THEN
ABORT("ERROR IN SETBP");
PI←NODE:INFO[PK];
IF B=PLACE_INFO:BASE[PI] THEN DONE;
IF ¬REASONABLE_BASE(B,PLACE_INFO:VBL[PI]) THEN DONE;
IF ¬ASK("BASE "&NODE:PNAME[PLACE_INFO:VBL[PI]]&" ON "&
NODE:PNAME[B]&"?") THEN DONE;
SETB(PK,B);
PK←NODE:EBRO[PK];
END;
PK←NODE:YBRO[PL]; ! propogate forwards;
WHILE PK≠NULL_RECORD DO
BEGIN
! only ask guy if it seems reasonable to do so.
;
IF NODE:KIND[PK]≠PLACE_KIND THEN
ABORT("ERROR IN SETBP");
PI←NODE:INFO[PK];
IF B=PLACE_INFO:BASE[PI] THEN DONE;
IF ¬REASONABLE_BASE(B,PLACE_INFO:VBL[PI]) THEN DONE;
IF ¬ASK("AFFIX "&NODE:PNAME[PLACE_INFO:VBL[PI]]&" TO "&
NODE:PNAME[B]&"?") THEN DONE;
SETB(PK,B);
PK←NODE:YBRO[PK];
END;
END;
! toplevel;
PROCEDURE TOPLEVEL;
BEGIN
LABEL MAIN_LOOP;
PROCEDURE PUNT;
BEGIN
! this procedure is used to escape to toplevel;
GO TO MAIN_LOOP;
END;
ESCAPE←NEW;
ASSIGN(ESCAPE,PUNT); ! we hope kick will not be blocked;
! First, some initialzations. ;
WORLD←NEW_NODE("WORLD");
ARM←NEW_NODE("ARM");
POINTER←NEW_NODE("POINTER");
FIDUCIAL←NEW_NODE("FIDUCIAL");
AFX_NODE(ARM,WORLD,NRGLNK);
AFX_NODE(POINTER,ARM,NRGLNK);
AFX_NODE(FIDUCIAL,WORLD,NRGLNK);
PUSHSTK($CURDAD,WORLD);
PUSHSTK($CURPATH,WORLD);
PUSHSTK($CURREF,WORLD);
PUSHSTK($CURMOVE,ARM);
PUSHSTK($CURTREE,WORLD);
PUSHSTK($CURNODE,WORLD);
M0←NEW_NODE("M0");
AFX_NODE(M0,WORLD,NRGLNK);
PROGRAM←NEW_NODE("PROGRAM",BLOCK_KIND);
PUSHSTK($CURSTMNT,PROGRAM);
PUSHSTK($CURPROG,PROGRAM);
LASTCURSOR←$CURNODE;
LASTARITH←$ASTACK;
SETFORMAT(0,3);
MAXDEPTH←999;
READARM;
DPYCLR;
DPYSET(DBUF);
TYPLOC(PPTMAR-CHRSIZE,DBMAR);
DPYOUT(1);
! now execute;
MAIN_LOOP:
UPDSUPPRESS←0;
UPDATE;
OUTSTR("BAIL is your command scanner.");
;BAIL;;
GO TO MAIN_LOOP;
END;
! main program;
TOPLEVEL;
XIT:END "HAIRY"